home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Internals / Utils.pm < prev   
Encoding:
Perl POD Document  |  2009-06-26  |  16.2 KB  |  653 lines
  1. package CPANPLUS::Internals::Utils;
  2.  
  3. use strict;
  4.  
  5. use CPANPLUS::Error;
  6. use CPANPLUS::Internals::Constants;
  7.  
  8. use Cwd;
  9. use File::Copy;
  10. use Params::Check               qw[check];
  11. use Module::Load::Conditional   qw[can_load];
  12. use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  13.  
  14. local $Params::Check::VERBOSE = 1;
  15.  
  16. =pod
  17.  
  18. =head1 NAME
  19.  
  20. CPANPLUS::Internals::Utils
  21.  
  22. =head1 SYNOPSIS
  23.  
  24.     my $bool = $cb->_mkdir( dir => 'blah' );
  25.     my $bool = $cb->_chdir( dir => 'blah' );
  26.     my $bool = $cb->_rmdir( dir => 'blah' );
  27.  
  28.     my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
  29.     my $bool = $cb->_move( from => '/some/dir',  to => '/other/dir' );
  30.  
  31.     my $cont = $cb->_get_file_contents( file => '/path/to/file' );
  32.  
  33.  
  34.     my $version = $cb->_perl_version( perl => $^X );
  35.  
  36. =head1 DESCRIPTION
  37.  
  38. C<CPANPLUS::Internals::Utils> holds a few convenience functions for
  39. CPANPLUS libraries.
  40.  
  41. =head1 METHODS
  42.  
  43. =head2 $cb->_mkdir( dir => '/some/dir' )
  44.  
  45. C<_mkdir> creates a full path to a directory.
  46.  
  47. Returns true on success, false on failure.
  48.  
  49. =cut
  50.  
  51. sub _mkdir {
  52.     my $self = shift;
  53.  
  54.     my %hash = @_;
  55.  
  56.     my $tmpl = {
  57.         dir     => { required => 1 },
  58.     };
  59.  
  60.     my $args = check( $tmpl, \%hash ) or (
  61.         error(loc( Params::Check->last_error ) ), return
  62.     );       
  63.  
  64.     unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
  65.         error( loc("Could not use File::Path! This module should be core!") );
  66.         return;
  67.     }
  68.  
  69.     eval { File::Path::mkpath($args->{dir}) };
  70.  
  71.     if($@) {
  72.         chomp($@);
  73.         error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
  74.         return;
  75.     }
  76.  
  77.     return 1;
  78. }
  79.  
  80. =pod
  81.  
  82. =head2 $cb->_chdir( dir => '/some/dir' )
  83.  
  84. C<_chdir> changes directory to a dir.
  85.  
  86. Returns true on success, false on failure.
  87.  
  88. =cut
  89.  
  90. sub _chdir {
  91.     my $self = shift;
  92.     my %hash = @_;
  93.  
  94.     my $tmpl = {
  95.         dir     => { required => 1, allow => DIR_EXISTS },
  96.     };
  97.  
  98.     my $args = check( $tmpl, \%hash ) or return;
  99.  
  100.     unless( chdir $args->{dir} ) {
  101.         error( loc(q[Could not chdir into '%1'], $args->{dir}) );
  102.         return;
  103.     }
  104.  
  105.     return 1;
  106. }
  107.  
  108. =pod
  109.  
  110. =head2 $cb->_rmdir( dir => '/some/dir' );
  111.  
  112. Removes a directory completely, even if it is non-empty.
  113.  
  114. Returns true on success, false on failure.
  115.  
  116. =cut
  117.  
  118. sub _rmdir {
  119.     my $self = shift;
  120.     my %hash = @_;
  121.  
  122.     my $tmpl = {
  123.         dir     => { required => 1, allow => IS_DIR },
  124.     };
  125.  
  126.     my $args = check( $tmpl, \%hash ) or return;
  127.  
  128.     unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
  129.         error( loc("Could not use File::Path! This module should be core!") );
  130.         return;
  131.     }
  132.  
  133.     eval { File::Path::rmtree($args->{dir}) };
  134.  
  135.     if($@) {
  136.         chomp($@);
  137.         error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
  138.         return;
  139.     }
  140.  
  141.     return 1;
  142. }
  143.  
  144. =pod
  145.  
  146. =head2 $cb->_perl_version ( perl => 'some/perl/binary' );
  147.  
  148. C<_perl_version> returns the version of a certain perl binary.
  149. It does this by actually running a command.
  150.  
  151. Returns the perl version on success and false on failure.
  152.  
  153. =cut
  154.  
  155. sub _perl_version {
  156.     my $self = shift;
  157.     my %hash = @_;
  158.  
  159.     my $perl;
  160.     my $tmpl = {
  161.         perl    => { required => 1, store => \$perl },
  162.     };
  163.  
  164.     check( $tmpl, \%hash ) or return;
  165.     
  166.     my $perl_version;
  167.     ### special perl, or the one we are running under?
  168.     if( $perl eq $^X ) {
  169.         ### just load the config        
  170.         require Config;
  171.         $perl_version = $Config::Config{version};
  172.         
  173.     } else {
  174.         my $cmd  = $perl .
  175.                 ' -MConfig -eprint+Config::config_vars+version';
  176.         ($perl_version) = (`$cmd` =~ /version='(.*)'/);
  177.     }
  178.     
  179.     return $perl_version if defined $perl_version;
  180.     return;
  181. }
  182.  
  183. =pod
  184.  
  185. =head2 $cb->_version_to_number( version => $version );
  186.  
  187. Returns a proper module version, or '0.0' if none was available.
  188.  
  189. =cut
  190.  
  191. sub _version_to_number {
  192.     my $self = shift;
  193.     my %hash = @_;
  194.  
  195.     my $version;
  196.     my $tmpl = {
  197.         version => { default => '0.0', store => \$version },
  198.     };
  199.  
  200.     check( $tmpl, \%hash ) or return;
  201.  
  202.     return $version if $version =~ /^\.?\d/;
  203.     return '0.0';
  204. }
  205.  
  206. =pod
  207.  
  208. =head2 $cb->_whoami
  209.  
  210. Returns the name of the subroutine you're currently in.
  211.  
  212. =cut
  213.  
  214. sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
  215.  
  216. =pod
  217.  
  218. =head2 _get_file_contents( file => $file );
  219.  
  220. Returns the contents of a file
  221.  
  222. =cut
  223.  
  224. sub _get_file_contents {
  225.     my $self = shift;
  226.     my %hash = @_;
  227.  
  228.     my $file;
  229.     my $tmpl = {
  230.         file => { required => 1, store => \$file }
  231.     };
  232.  
  233.     check( $tmpl, \%hash ) or return;
  234.  
  235.     my $fh = OPEN_FILE->($file) or return;
  236.     my $contents = do { local $/; <$fh> };
  237.  
  238.     return $contents;
  239. }
  240.  
  241. =pod $cb->_move( from => $file|$dir, to => $target );
  242.  
  243. Moves a file or directory to the target.
  244.  
  245. Returns true on success, false on failure.
  246.  
  247. =cut
  248.  
  249. sub _move {
  250.     my $self = shift;
  251.     my %hash = @_;
  252.  
  253.     my $from; my $to;
  254.     my $tmpl = {
  255.         file    => { required => 1, allow => [IS_FILE,IS_DIR],
  256.                         store => \$from },
  257.         to      => { required => 1, store => \$to }
  258.     };
  259.  
  260.     check( $tmpl, \%hash ) or return;
  261.  
  262.     if( File::Copy::move( $from, $to ) ) {
  263.         return 1;
  264.     } else {
  265.         error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
  266.         return;
  267.     }
  268. }
  269.  
  270. =pod $cb->_copy( from => $file|$dir, to => $target );
  271.  
  272. Moves a file or directory to the target.
  273.  
  274. Returns true on success, false on failure.
  275.  
  276. =cut
  277.  
  278. sub _copy {
  279.     my $self = shift;
  280.     my %hash = @_;
  281.     
  282.     my($from,$to);
  283.     my $tmpl = {
  284.         file    =>{ required => 1, allow => [IS_FILE,IS_DIR],
  285.                         store => \$from },
  286.         to      => { required => 1, store => \$to }
  287.     };
  288.  
  289.     check( $tmpl, \%hash ) or return;
  290.  
  291.     if( File::Copy::copy( $from, $to ) ) {
  292.         return 1;
  293.     } else {
  294.         error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
  295.         return;
  296.     }
  297. }
  298.  
  299. =head2 $cb->_mode_plus_w( file => '/path/to/file' );
  300.  
  301. Sets the +w bit for the file.
  302.  
  303. Returns true on success, false on failure.
  304.  
  305. =cut
  306.  
  307. sub _mode_plus_w {
  308.     my $self = shift;
  309.     my %hash = @_;
  310.     
  311.     require File::stat;
  312.     
  313.     my $file;
  314.     my $tmpl = {
  315.         file    => { required => 1, allow => IS_FILE, store => \$file },
  316.     };
  317.     
  318.     check( $tmpl, \%hash ) or return;
  319.     
  320.     ### set the mode to +w for a file and +wx for a dir
  321.     my $x       = File::stat::stat( $file );
  322.     my $mask    = -d $file ? 0100 : 0200;
  323.     
  324.     if( $x and chmod( $x->mode|$mask, $file ) ) {
  325.         return 1;
  326.  
  327.     } else {        
  328.         error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
  329.         return;
  330.     }
  331. }    
  332.  
  333. =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
  334.  
  335. Turns a CPANPLUS::Config style C<host> entry into an URI string.
  336.  
  337. Returns the uri on success, and false on failure
  338.  
  339. =cut
  340.  
  341. sub _host_to_uri {
  342.     my $self = shift;
  343.     my %hash = @_;
  344.     
  345.     my($scheme, $host, $path);
  346.     my $tmpl = {
  347.         scheme  => { required => 1,             store => \$scheme },
  348.         host    => { default  => 'localhost',   store => \$host },
  349.         path    => { default  => '',            store => \$path },
  350.     };       
  351.  
  352.     check( $tmpl, \%hash ) or return;
  353.  
  354.     ### it's an URI, so unixify the path.
  355.     ### VMS has a special method for just that
  356.     $path = ON_VMS
  357.                 ? VMS::Filespec::unixify($path) 
  358.                 : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
  359.  
  360.     return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); 
  361. }
  362.  
  363. =head2 $cb->_vcmp( VERSION, VERSION );
  364.  
  365. Normalizes the versions passed and does a '<=>' on them, returning the result.
  366.  
  367. =cut
  368.  
  369. sub _vcmp {
  370.     my $self = shift;
  371.     my ($x, $y) = @_;
  372.     
  373.     s/_//g foreach $x, $y;
  374.  
  375.     return $x <=> $y;
  376. }
  377.  
  378. =head2 $cb->_home_dir
  379.  
  380. Returns the user's homedir, or C<cwd> if it could not be found
  381.  
  382. =cut
  383.  
  384. sub _home_dir {
  385.     my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
  386.  
  387.     for my $env ( @os_home_envs ) {
  388.         next unless exists $ENV{ $env };
  389.         next unless defined $ENV{ $env } && length $ENV{ $env };
  390.         return $ENV{ $env } if -d $ENV{ $env };
  391.     }
  392.  
  393.     return cwd();
  394. }
  395.  
  396. =head2 $path = $cb->_safe_path( path => $path );
  397.  
  398. Returns a path that's safe to us on Win32 and VMS. 
  399.  
  400. Only cleans up the path on Win32 if the path exists.
  401.  
  402. On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
  403.  
  404. =cut
  405.  
  406. sub _safe_path {
  407.     my $self = shift;
  408.     
  409.     my %hash = @_;
  410.     
  411.     my $path;
  412.     my $tmpl = {
  413.         path  => { required => 1,     store => \$path },
  414.     };       
  415.  
  416.     check( $tmpl, \%hash ) or return;
  417.     
  418.     if( ON_WIN32 ) {
  419.         ### only need to fix it up if there's spaces in the path   
  420.         return $path unless $path =~ /\s+/;
  421.         
  422.         ### clean up paths if we are on win32
  423.         return Win32::GetShortPathName( $path ) || $path;
  424.  
  425.     } elsif ( ON_VMS ) {
  426.         ### XXX According to John Malmberg, there's an VMS issue:
  427.         ### catdir on VMS can not currently deal with directory components
  428.         ### with dots in them.  
  429.         ### Fixing this is a a three step procedure, which will work for 
  430.         ### VMS in its traditional ODS-2 mode, and it will also work if 
  431.         ### VMS is in the ODS-5 mode that is being implemented.
  432.         ### If the path is already in VMS syntax, assume that we are done.
  433.  
  434.         ### VMS format is a path with a trailing ']' or ':'
  435.         return $path if $path =~ /\:|\]$/;
  436.  
  437.         ### 1. Make sure that the value to be converted, $path is 
  438.         ### in UNIX directory syntax by appending a '/' to it.
  439.         $path .= '/' unless $path =~ m|/$|;
  440.  
  441.         ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
  442.         ### underscores if needed.  The trailing '/' is needed as so that
  443.         ### C<vmsify> knows that it should use directory translation instead of
  444.         ### filename translation, as filename translation leaves one dot.
  445.         $path = VMS::Filespec::vmsify( $path );
  446.  
  447.         ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( 
  448.         ### $path . '/') to remove the directory delimiters.
  449.  
  450.         ### From John Malmberg:
  451.         ### File::Spec->catdir will put the path back together.
  452.         ### The '/' trick only works if the string is a directory name 
  453.         ### with UNIX style directory delimiters or no directory delimiters.  
  454.         ### It is to force vmsify to treat the input specification as UNIX.
  455.         ###
  456.         ### There is a VMS::Filespec::unixpath() to do the appending of the '/'
  457.         ### to the specification, which will do a VMS::Filespec::vmsify() 
  458.         ### if needed.
  459.         ### However it is not a good idea to call vmsify() on a pathname
  460.         ### returned by unixify(), and it is not a good idea to call unixify()
  461.         ### on a pathname returned by vmsify().  Because of the nature of the
  462.         ### conversion, not all file specifications can make the round trip.
  463.         ###
  464.         ### I think that directory specifications can safely make the round
  465.         ### trip, but not ones containing filenames.
  466.         $path = File::Spec->catdir( File::Spec->splitdir( $path ) )
  467.     }
  468.     
  469.     return $path;
  470. }
  471.  
  472.  
  473. =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
  474.  
  475. Splits the name of a CPAN package string up in it's package, version 
  476. and extension parts.
  477.  
  478. For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
  479.  
  480.     Package:    Foo-Bar
  481.     Version:    1.2
  482.     Extension:  tar.gz
  483.  
  484. =cut
  485.  
  486. {   my $del_re = qr/[-_\+]/i;           # delimiter between elements
  487.     my $pkg_re = qr/[a-z]               # any letters followed by 
  488.                     [a-z\d]*            # any letters, numbers
  489.                     (?i:\.pm)?          # followed by '.pm'--authors do this :(
  490.                     (?:                 # optionally repeating:
  491.                         $del_re         #   followed by a delimiter
  492.                         [a-z]           #   any letters followed by 
  493.                         [a-z\d]*        #   any letters, numbers                        
  494.                         (?i:\.pm)?      # followed by '.pm'--authors do this :(
  495.                     )*
  496.                 /xi;   
  497.     
  498.     my $ver_re = qr/[a-z]*\d+[a-z]*     # contains a digit and possibly letters
  499.                     (?:
  500.                         [-._]           # followed by a delimiter
  501.                         [a-z\d]+        # and more digits and or letters
  502.                     )*?
  503.                 /xi;
  504.  
  505.     my $ext_re = qr/[a-z]               # a letter, followed by
  506.                     [a-z\d]*            # letters and or digits, optionally
  507.                     (?:                 
  508.                         \.              #   followed by a dot and letters
  509.                         [a-z\d]+        #   and or digits (like .tar.bz2)
  510.                     )?                  #   optionally
  511.                 /xi;
  512.  
  513.     my $ver_ext_re = qr/
  514.                         ($ver_re+)      # version, optional
  515.                         (?:
  516.                             \.          # a literal .
  517.                             ($ext_re)   # extension,
  518.                         )?              # optional, but requires version
  519.                 /xi;
  520.                 
  521.     ### composed regex for CPAN packages
  522.     my $full_re = qr/
  523.                     ^
  524.                     ($pkg_re+)          # package
  525.                     (?: 
  526.                         $del_re         # delimiter
  527.                         $ver_ext_re     # version + extension
  528.                     )?
  529.                     $                    
  530.                 /xi;
  531.                 
  532.     ### composed regex for perl packages
  533.     my $perl    = PERL_CORE;
  534.     my $perl_re = qr/
  535.                     ^
  536.                     ($perl)             # package name for 'perl'
  537.                     (?:
  538.                         $ver_ext_re     # version + extension
  539.                     )?
  540.                     $
  541.                 /xi;       
  542.  
  543.  
  544. sub _split_package_string {
  545.         my $self = shift;
  546.         my %hash = @_;
  547.         
  548.         my $str;
  549.         my $tmpl = { package => { required => 1, store => \$str } };
  550.         check( $tmpl, \%hash ) or return;
  551.         
  552.         
  553.         ### 2 different regexes, one for the 'perl' package, 
  554.         ### one for ordinary CPAN packages.. try them both, 
  555.         ### first match wins.
  556.         for my $re ( $full_re, $perl_re ) {
  557.             
  558.             ### try the next if the match fails
  559.             $str =~ $re or next;
  560.  
  561.             my $pkg = $1 || ''; 
  562.             my $ver = $2 || '';
  563.             my $ext = $3 || '';
  564.  
  565.             ### this regex resets the capture markers!
  566.             ### strip the trailing delimiter
  567.             $pkg =~ s/$del_re$//;
  568.             
  569.             ### strip the .pm package suffix some authors insist on adding
  570.             $pkg =~ s/\.pm$//i;
  571.  
  572.             return ($pkg, $ver, $ext );
  573.         }
  574.         
  575.         return;
  576.     }
  577. }
  578.  
  579. {   my %escapes = map {
  580.         chr($_) => sprintf("%%%02X", $_)
  581.     } 0 .. 255;  
  582.     
  583.     sub _uri_encode {
  584.         my $self = shift;
  585.         my %hash = @_;
  586.         
  587.         my $str;
  588.         my $tmpl = {
  589.             uri => { store => \$str, required => 1 }
  590.         };
  591.         
  592.         check( $tmpl, \%hash ) or return;
  593.  
  594.         ### XXX taken straight from URI::Encode
  595.         ### Default unsafe characters.  RFC 2732 ^(uric - reserved)
  596.         $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
  597.     
  598.         return $str;          
  599.     }
  600.     
  601.     
  602.     sub _uri_decode {
  603.         my $self = shift;
  604.         my %hash = @_;
  605.         
  606.         my $str;
  607.         my $tmpl = {
  608.             uri => { store => \$str, required => 1 }
  609.         };
  610.         
  611.         check( $tmpl, \%hash ) or return;
  612.     
  613.         ### XXX use unencode routine in utils?
  614.         $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 
  615.     
  616.         return $str;    
  617.     }
  618. }
  619.  
  620. sub _update_timestamp {
  621.     my $self = shift;
  622.     my %hash = @_;
  623.     
  624.     my $file;
  625.     my $tmpl = {
  626.         file => { required => 1, store => \$file, allow => FILE_EXISTS }
  627.     };
  628.     
  629.     check( $tmpl, \%hash ) or return;
  630.    
  631.     ### `touch` the file, so windoze knows it's new -jmb
  632.     ### works on *nix too, good fix -Kane
  633.     ### make sure it is writable first, otherwise the `touch` will fail
  634.  
  635.     my $now = time;
  636.     unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
  637.         error( loc("Couldn't touch %1", $file) );
  638.         return;
  639.     }
  640.     
  641.     return 1;
  642. }
  643.  
  644.  
  645. 1;
  646.  
  647. # Local variables:
  648. # c-indentation-style: bsd
  649. # c-basic-offset: 4
  650. # indent-tabs-mode: nil
  651. # End:
  652. # vim: expandtab shiftwidth=4:
  653.